home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-secsta.adb < prev    next >
Text File  |  1994-05-19  |  10KB  |  273 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --               S Y S T E M . S E C O N D A R Y _ S T A C K                --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.14 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with System;                    use System;
  26. with System.Storage_Elements;   use System.Storage_Elements;
  27. with System.Task_Specific_Data; use System.Task_Specific_Data;
  28.  
  29. with Unchecked_Conversion;
  30. with Unchecked_Deallocation;
  31.  
  32. package body System.Secondary_Stack is
  33.  
  34.    --  This secondary stack implementation is a combinaison of 2 models. If
  35.    --  there are fewer allocations during a Push Cycle than the size provided
  36.    --  during Initialize then the stack behaves as an Array and no dynamic
  37.    --  (de)allocation is performed. If the array runs out of space then a
  38.    --  linked list of memory chunks is used (one chunk for each Allocate)
  39.    --  and then dynamic (de)allocation is heavily used.
  40.  
  41.  
  42.    --   Stack
  43.    --
  44.    --    +---------+      +--------------------------------------------------+
  45.    --    | Heap  --|----> |  chunk of memory corresponding to 1 allocation   |
  46.    --    +---------+      +--------------------------------------------------+
  47.    --    | Mark    |
  48.    --    +---------+
  49.    --    | Prev |  |
  50.    --    +------+--+
  51.    --           |
  52.    --           V
  53.    --    +---------+     +--------------------+
  54.    --    |       --|---->|                    |
  55.    --    +---------+     +--------------------+
  56.    --    |         |
  57.    --    +---------+
  58.    --    |      |  |
  59.    --    +------+--+                        +--------------+
  60.    --           |       +-----------------> |              | <-+
  61.    --           V       |                   |              |   |
  62.    --    +---------+    |                   |              |   |
  63.    --    |       --|----+                   +- - - - - - - +   |
  64.    --    +---------+                    +-> |     mark   --|---+
  65.    --    |  mark --|--+                 |   +- - - - - -- -+
  66.    --    +---------+  |                 |   |              |
  67.    --    |  null   |  |                 |   |              |
  68.    --    +---------+  |                 |   |              |
  69.    --    (main stack) |                 |   +- - - - - - - +
  70.    --                 +------------->   +---|--   mark     |
  71.    --                                       +- - - - - - - +
  72.    --                                       |              |
  73.    --                                       |              |
  74.    --                                       +--------------+
  75.    --                                          (main array)
  76.  
  77.    type Memory is array (Mark_Id range <>) of Storage_Element;
  78.    type Memory_Access is access Memory;
  79.  
  80.    --  Stack abstaction :
  81.  
  82.    --    Prev : if this field is Null is means that this stack elmt is the
  83.    --           main stack. Otherwise the main stack has run out of space and
  84.    --           this stack elmt is part of the auxiliary linked list of stacks
  85.  
  86.    --    Mark : for the main stack, gives the index of the first free memory
  87.    --           element. Otherwise, is incremented by 1 for each new Stack elmt
  88.  
  89.    --    Heap : Contains the actual data. Only one allocation for each stack
  90.    --           elmt other than the main stack where all allocations are
  91.    --           separated by Marks which form a linked list inside the Heap.
  92.  
  93.    type Stack_Id;
  94.    type Stack_Access is access Stack_Id;
  95.  
  96.    type Stack_Id is record
  97.       Heap : Memory_Access;
  98.       Mark : Mark_Id := Mark_Id'First;
  99.       Prev : Stack_Access;
  100.    end record;
  101.  
  102.    Mark_Length : constant Mark_Id := Mark_Id'Size / Storage_Unit;
  103.  
  104.    --  Package Convert is needed to peek and poke marks in memory
  105.  
  106.    package Convert is new Address_To_Access_Conversions (Mark_Id);
  107.    use Convert;
  108.  
  109.    function To_Addr is new
  110.      Unchecked_Conversion (Stack_Access, Address);
  111.  
  112.    function From_Addr is new
  113.      Unchecked_Conversion (Address, Stack_Access);
  114.  
  115.    procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Access);
  116.    procedure Free is new Unchecked_Deallocation (Memory, Memory_Access);
  117.  
  118.    -----------------
  119.    -- SS_Allocate --
  120.    -----------------
  121.  
  122.    function SS_Allocate (Size : Natural) return System.Address is
  123.       Siz        : constant Mark_Id      := Mark_Id (Size);
  124.       Stack_Addr : constant Address      := Get_Sec_Stack_Addr;
  125.       Stack      : constant Stack_Access := From_Addr (Stack_Addr);
  126.       Next_Mark  : constant Mark_Id      := Stack.Mark + Siz + Mark_Length;
  127.       Res        : Address;
  128.  
  129.    begin
  130.       --  Normal allocation
  131.  
  132.       if Stack.Prev = null
  133.         and then Next_Mark < Stack.Heap'Last
  134.       then
  135.          --  The value of the next_mark if the index of previous mark
  136.  
  137.          To_Pointer (Stack.Heap (Next_Mark)'Address).all := Stack.Mark;
  138.          Stack.Mark := Next_Mark;
  139.          return Stack.Heap (Next_Mark - Siz)'Address;
  140.  
  141.       else
  142.          declare
  143.             S : Stack_Access := new Stack_Id;
  144.  
  145.          begin
  146.             S.Heap := new Memory (Mark_Id'First .. Mark_Id'First + Siz - 1);
  147.             S.Mark := Stack.Mark + 1;
  148.             S.Prev := Stack;
  149.             Set_Sec_Stack_Addr (To_Addr (S));
  150.             return S.Heap (Mark_Id'First)'Address;
  151.          end;
  152.       end if;
  153.    end SS_Allocate;
  154.  
  155.    -------------
  156.    -- SS_Init --
  157.    -------------
  158.  
  159.    procedure SS_Init (Stk : out Address; Size : Natural) is
  160.       Stack : Stack_Access;
  161.  
  162.    begin
  163.       Stack := new Stack_Id;
  164.       Stack.Heap :=
  165.         new Memory (Mark_Id'First .. Mark_Id'First + Mark_Id (Size) - 1);
  166.       Stack.Mark := Mark_Id'First;
  167.       Stack.Prev := null;
  168.       Stk := To_Addr (Stack);
  169.    end SS_Init;
  170.  
  171.    -------------
  172.    -- SS_Free --
  173.    -------------
  174.  
  175.    procedure SS_Free (Stk : Address) is
  176.       Stack : Stack_Access := From_Addr (Stk);
  177.       S     : Stack_Access := Stack;
  178.  
  179.    begin
  180.       while Stack /= null loop
  181.          Stack := Stack.Prev;
  182.          Free (S.Heap);
  183.          Free (S);
  184.          S := Stack;
  185.       end loop;
  186.    end SS_Free;
  187.  
  188.    -------------
  189.    -- SS_Mark --
  190.    -------------
  191.  
  192.    function SS_Mark return Mark_Id is
  193.       Stack_Addr : constant Address      := Get_Sec_Stack_Addr;
  194.       Stack      : constant Stack_Access := From_Addr (Stack_Addr);
  195.  
  196.    begin
  197.       return Stack.Mark;
  198.    end SS_Mark;
  199.  
  200.    ----------------
  201.    -- SS_Release --
  202.    ----------------
  203.  
  204.    procedure SS_Release (M : Mark_Id) is
  205.       Stack_Addr : constant Address := Get_Sec_Stack_Addr;
  206.       Stack      : Stack_Access     := From_Addr (Stack_Addr);
  207.  
  208.    begin
  209.       --  Deallocation of the overflow list
  210.  
  211.       while Stack.Mark /= M  and then Stack.Prev /= null loop
  212.          declare
  213.             S : Stack_Access := Stack;
  214.  
  215.